home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
bbs
/
mfm_111b.zip
/
AREA.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-01-07
|
13KB
|
387 lines
{========================================================================}
Procedure GetAreaTable;
Var
AreaRecordNumber : Word;
MaxAreaRecord : ^AreaRecordType;
Begin
NumberOfAreaEntries := 0; AreaRecordNumber := 1;
If OpenMaxArea Then
Begin
MaxAreaRecord := RecordBuffer;
While GetMaxArea(AreaRecordNumber) = 0 Do
Begin
OkToAddToList := False;
Inc(AreaRecordNumber);
WorkString := Array2String(@MaxAreaRecord^.FilePath);
FindFirst(WorkString+'*.*',AnyFile,DirInfo);
If DosError = 0 Then
Begin
OkToAddToList := True;
End
Else
Begin
Assign(FileList,WorkString+'FILES.BBS');
{$I-} ReWrite(FileList); {$I+}
If IOresult = 0 Then
Begin
Close(FileList);
OkToAddToList := True;
End;
End;
If Length(WorkString) = 0 Then OkToAddToList := False;
If OkToAddToList Then
Begin
Inc(NumberOfAreaEntries);
If MaxAvail > SizeOf(ListRecord) Then
Begin
New(NewAreaEntry);
If NumberOfAreaEntries = 1 Then
Begin
FirstAreaEntry := NewAreaEntry;
NewAreaEntry^.PrevEntry := NIL;
OldAreaEntry := FirstAreaEntry;
End
Else
Begin
NewAreaEntry^.PrevEntry := OldAreaEntry;
OldAreaEntry^.NextEntry := NewAreaEntry;
OldAreaEntry := NewAreaEntry;
End;
NewAreaEntry^.AreaPath := WorkString;
NewAreaEntry^.Name := Array2String(@MaxAreaRecord^.Name);
NewAreaEntry^.Changed := False;
End;
End;
End;
End;
CloseMaxArea;
If NumberOfAreaEntries = 0 Then
Begin
WriteLn('No areas found!');
Halt(1);
End
Else
Begin
NewAreaEntry^.NextEntry := NIL;
AreaCounter := 1; ChooseAreaEntry := FirstAreaEntry;
End;
End;
{========================================================================}
Procedure DisplayArea(AreaNumber : Byte; TempAreaEntry : AreaPtr);
Var
Row, Col : Byte;
Begin
WorkString := TempAreaEntry^.AreaPath;
Delete(WorkString,Length(WorkString),1);
WorkString := RCopy(WorkString,1,RPos('\',WorkString)-1);
If AreaNumber = 1 Then Row := 1 Else Row := (((AreaNumber-1) Div Columns)+1);
If AreaNumber = 1 Then Col := 1 Else Col := (((AreaNumber-1) Mod Columns)*ColumnPos)+1;
If Col = 1 Then
Begin
AnsiGotoXY(Row,1); AnsiClearToEOL;
End;
AnsiGotoXY(Row,Col);
NewTextColor(LightRed);
Write(' '+WorkString);
NewTextColor(White);
End;
{========================================================================}
Procedure BlankAreaPointer(AreaNumber : Byte);
Var
Row, Col : Byte;
Begin
If AreaNumber = 1 Then Row := 1 Else Row := (((AreaNumber-1) Div Columns)+1);
If AreaNumber = 1 Then Col := 1 Else Col := (((AreaNumber-1) Mod Columns)*ColumnPos)+1;
AnsiGotoXY(Row,Col);
Write(' ');
AnsiGotoXY(24,80);
End;
{========================================================================}
Procedure ShowAreaPointer(AreaNumber : Byte);
Var
Row, Col : Byte;
Begin
AnsiGotoXY(25,1); AnsiClearToEol;
Write(ChooseAreaEntry^.AreaPath);
If AreaNumber = 1 Then Row := 1 Else Row := (((AreaNumber-1) Div Columns)+1);
If AreaNumber = 1 Then Col := 1 Else Col := (((AreaNumber-1) Mod Columns)*ColumnPos)+1;
AnsiGotoXY(Row,Col);
Write('>');
AnsiGotoXY(24,80);
End;
{========================================================================}
Procedure DisplayAreaList;
Var
AreaCounter : Byte;
Begin
OldAreaEntry := FirstAreaEntry; AreaCounter := 0;
While OldAreaEntry^.NextEntry <> NIL Do
Begin
Inc(AreaCounter);
DisplayArea(AreaCounter, OldAreaEntry);
OldAreaEntry := OldAreaEntry^.NextEntry;
End;
Inc(AreaCounter);
DisplayArea(AreaCounter, OldAreaEntry);
End;
{========================================================================}
Procedure AddTempArea;
Var
NewAreaName : String;
Begin
AnsiGotoXY(25,1); AnsiClearToEOL;
Write('Enter new temporary path: ');
NewAreaName := UpperString(EditLine('',40,25,26));
If Length(NewAreaName) > 0 Then
Begin
If Copy(NewAreaName,Length(NewAreaName),1) <> '\' Then NewAreaName := NewAreaName + '\';
OkToAddToList := False;
FindFirst(NewAreaName+'*.*',Archive,DirInfo);
If DosError = 0 Then
Begin
OkToAddToList := True;
End
Else
Begin
Assign(FileList,NewAreaName+'FILES.BBS');
{$I-} ReWrite(FileList); {$I+}
If IOresult = 0 Then
Begin
Close(FileList);
OkToAddToList := True;
End;
End;
If OkToAddToList Then
Begin
If MaxAvail > SizeOf(ListRecord) Then
Begin
New(NewAreaEntry);
NewAreaEntry^.PrevEntry := OldAreaEntry;
OldAreaEntry^.NextEntry := NewAreaEntry;
OldAreaEntry := NewAreaEntry;
NewAreaEntry^.AreaPath := NewAreaName;
NewAreaEntry^.NextEntry := NIL;
Inc(NumberOfAreaEntries);
DisplayAreaList;
ShowAreaPointer(AreaCounter);
End;
End
Else
Begin
AnsiGotoXY(25,1); AnsiClearToEOL;
Write('Directory '+NewAreaName+' not found!');
End;
End;
End;
{========================================================================}
Procedure MatchMask;
Var
AreaPointer : AreaPtr;
AreaPointerPosition : Byte;
Matched : Boolean;
Begin
Matched := False; AreaPointer := FirstAreaEntry; AreaPointerPosition := 1;
WorkString := AreaPointer^.AreaPath;
Delete(WorkString,Length(WorkString),1);
WorkString := RCopy(WorkString,1,RPos('\',WorkString)-1);
If Pos(AreaMask,UpperString(WorkString)) = 1 Then Matched := True;
While (AreaPointer^.NextEntry <> NIL) And (Not Matched) Do
Begin
AreaPointer := AreaPointer^.NextEntry; Inc(AreaPointerPosition);
WorkString := AreaPointer^.AreaPath;
Delete(WorkString,Length(WorkString),1);
WorkString := RCopy(WorkString,1,RPos('\',WorkString)-1);
If Pos(AreaMask,UpperString(WorkString)) = 1 Then Matched := True;
End;
If Matched Then
Begin
BlankAreaPointer(AreaCounter);
ChooseAreaEntry := AreaPointer;
AreaCounter := AreaPointerPosition;
ShowAreaPointer(AreaCounter);
End
Else
Begin
Delete(AreaMask,Length(AreaMask),1);
End;
End;
{========================================================================}
Function ChooseArea : String;
Var
Cax : Char;
Cab : Byte;
Begin
DisplayAreaList;
ShowAreaPointer(AreaCounter);
AreaMask := '';
Repeat
Gbx := GetInput;
Cax := Upcase(Chr(Gbx));
If Gbx = 0 Then
Begin
Gbx := GetInput;
Case Gbx Of
71 : Cax := '7';
72 : Cax := '8';
73 : Cax := '9';
75 : Cax := '4';
77 : Cax := '6';
79 : Cax := '1';
80 : Cax := '2';
81 : Cax := '3';
End;
End;
Case Cax Of
'1' : Begin
BlankAreaPointer(AreaCounter);
AreaCounter := (NumberOfAreaEntries - (NumberOfAreaEntries Mod Columns)) + 1;
If AreaCounter > NumberOfAreaEntries Then AreaCounter := NumberOfAreaEntries - (Columns-1);
ChooseAreaEntry := FirstAreaEntry;
For Cab := 1 To AreaCounter-1 Do ChooseAreaEntry := ChooseAreaEntry^.NextEntry;
ShowAreaPointer(AreaCounter);
End;
'2' : Begin
If AreaCounter+Columns <= NumberOfAreaEntries Then
Begin
BlankAreaPointer(AreaCounter);
AreaCounter := AreaCounter + Columns;
For Cab := 1 To Columns Do ChooseAreaEntry := ChooseAreaEntry^.NextEntry;
ShowAreaPointer(AreaCounter);
End;
End;
'3' : Begin
BlankAreaPointer(AreaCounter);
AreaCounter := NumberOfAreaEntries - (NumberOfAreaEntries Mod Columns);
ChooseAreaEntry := FirstAreaEntry;
For Cab := 1 To AreaCounter-1 Do ChooseAreaEntry := ChooseAreaEntry^.NextEntry;
ShowAreaPointer(AreaCounter);
End;
'4' : Begin
If AreaCounter > 1 Then
Begin
ChooseAreaEntry := ChooseAreaEntry^.PrevEntry;
BlankAreaPointer(AreaCounter);
Dec(AreaCounter);
ShowAreaPointer(AreaCounter);
End;
End;
'6' : Begin
If AreaCounter < NumberOfAreaEntries Then
Begin
ChooseAreaEntry := ChooseAreaEntry^.NextEntry;
BlankAreaPointer(AreaCounter);
Inc(AreaCounter);
ShowAreaPointer(AreaCounter);
End;
End;
'7' : Begin
ChooseAreaEntry := FirstAreaEntry;
BlankAreaPointer(AreaCounter);
AreaCounter := 1;
ShowAreaPointer(AreaCounter);
End;
'8' : Begin
If AreaCounter-Columns > 0 Then
Begin
BlankAreaPointer(AreaCounter);
AreaCounter := AreaCounter - Columns;
For Cab := 1 To Columns Do ChooseAreaEntry := ChooseAreaEntry^.PrevEntry;
ShowAreaPointer(AreaCounter);
End;
End;
'9' : Begin
BlankAreaPointer(AreaCounter);
AreaCounter := Columns;
ChooseAreaEntry := FirstAreaEntry;
For Cab := 1 To Columns-1 Do ChooseAreaEntry := ChooseAreaEntry^.NextEntry;
ShowAreaPointer(AreaCounter);
End;
^I : AddTempArea;
'?' : Begin
AreaHelp;
DisplayAreaList;
ShowAreaPointer(AreaCounter);
End;
Else
If Cax = ^H Then
Begin
Delete(AreaMask,Length(AreaMask),1);
MatchMask
End;
If Cax In [':','A'..'Z','a'..'z'] Then
Begin
AreaMask := AreaMask + Cax;
MatchMask
End;
AnsiGotoXY(25,1); AnsiClearToEOL;
Write(AreaMask);
End;
Until Cax In [^M,^Q,^[];
If Cax In [^Q,^[] Then
Begin
If Cax = ^Q Then
Begin
ChooseArea := 'QUITQUICK';
End
Else
Begin
ChooseArea := 'QUIT';
End;
End
Else
Begin
ChooseArea := ChooseAreaEntry^.AreaPath;
End;
End;
{========================================================================}
Procedure ChooseNewArea;
Var
TempArea : String;
Begin
If Altered Then
Begin
SaveList;
Altered := False;
End;
BeginSort := NIL; EndSort := NIL;
NextPrintEntry := FirstEntry;
If NumberOfEntries > 0 Then
Begin
While NextPrintEntry^.NextEntry <> NIL Do
Begin
NextPrintEntry := NextPrintEntry^.NextEntry;
Dispose(NextPrintEntry^.PrevEntry);
End;
Dispose(NextPrintEntry);
End;
SetupScreen;
Repeat
TempArea := ChooseArea;
If TempArea = 'QUITQUICK' Then
Begin
Halt(1);
End;
If TempArea <> 'QUIT' Then
Begin
FileAreaPath := TempArea;
End;
NumberOfEntries := 0; BuildList;
If NumberOfEntries = 0 Then
Begin
AnsiGotoXY(25,1); AnsiClearToEOL;
Write('This area contains no files!');
End;
Until (NumberOfEntries > 0) Or (TempArea = 'QUIT');
If NumberOfEntries > 0 Then
Begin
If TempArea <> 'QUIT' Then
Begin
Row := 1;
CurrentEntry := FirstEntry;
TopEntry := FirstEntry;
End;
DisplayScreen;
End;
End;
{========================================================================}
